[ Back ] [ Home ] [ Up ] [ Next ]

للإضافة الى المفضلة

اكتب التالي في موديل  Module

Private Declare Function SHGetSpecialFolderLocation _
      Lib "shell32.dll" (ByVal hwndOwner As Long, _
      ByVal nFolder As SpecialShellFolderIDs, _
      pidl As Long) As Long

Private Declare Function SHGetPathFromIDList _
      Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
      (ByVal pidl As Long, _
      ByVal pszPath As String) As Long

Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
      (ByVal pv As Long)

Public Enum SpecialShellFolderIDs
      CSIDL_DESKTOP = &H0
      CSIDL_INTERNET = &H1
      CSIDL_PROGRAMS = &H2
      CSIDL_CONTROLS = &H3
      CSIDL_PRINTERS = &H4
      CSIDL_PERSONAL = &H5
      CSIDL_FAVORITES = &H6
      CSIDL_STARTUP = &H7
      CSIDL_RECENT = &H8
      CSIDL_SENDTO = &H9
      CSIDL_BITBUCKET = &HA
      CSIDL_STARTMENU = &HB
      CSIDL_DESKTOPDIRECTORY = &H10
      CSIDL_DRIVES = &H11
      CSIDL_NETWORK = &H12
      CSIDL_NETHOOD = &H13
      CSIDL_FONTS = &H14
      CSIDL_TEMPLATES = &H15
      CSIDL_COMMON_STARTMENU = &H16
      CSIDL_COMMON_PROGRAMS = &H17
      CSIDL_COMMON_STARTUP = &H18
      CSIDL_COMMON_DESKTOPDIRECTORY = &H19
      CSIDL_APPDATA = &H1A
      CSIDL_PRINTHOOD = &H1B
      CSIDL_ALTSTARTUP = &H1D
      CSIDL_COMMON_ALTSTARTUP = &H1E
      CSIDL_COMMON_FAVORITES = &H1F
      CSIDL_INTERNET_CACHE = &H20
      CSIDL_COOKIES = &H21
      CSIDL_HISTORY = &H22
End Enum


Public Sub AddFavorite(SiteName As String, URL As String)
      Dim pidl As Long
      Dim intFile As Integer
      Dim strFullPath As String

      On Error GoTo Goodbye

      intFile = FreeFile
      strFullPath = Space(255)


      If SHGetSpecialFolderLocation(0, CSIDL_FAVORITES, pidl) = 0 Then
            If pidl Then
                  If SHGetPathFromIDList(pidl, strFullPath) Then
                        If InStr(1, strFullPath, Chr(0)) Then
                              strFullPath = Mid(strFullPath, 1, _
                                    InStr(1, strFullPath, Chr(0)) - 1)
                        End If

                        If Right(strFullPath, 1) <> "\" Then
                              strFullPath = strFullPath & "\"
                        End If

                        strFullPath = strFullPath & SiteName & ".URL"
                        Open strFullPath For Output As #intFile
                        Print #intFile, "[InternetShortcut]"
                        Print #intFile, "URL=" & URL
                        Close #intFile

                  End If
                  CoTaskMemFree pidl
            End If
      End If

Goodbye:

End Sub

استدعي الاجراء من اي مكان تريد

AddFavorite "Net.فيجول", "http://www.vnet.7p.com/"